;;************************************************************************
;; boxplot1.lsp 
;; contains code for boxplot  
;; copyright (c) 1993-98 by Forrest W. Young
;;************************************************************************

(defun boxplot (data &key (title "Box, Diamond and Dot Plot") 
                     variable-labels point-labels (jitter t) 
                     (y-axis-label "Data") (content-only nil)
                     (legend1 (send current-object :name))  (legend2 " ")
                     (boxes t) diamonds median-line mean-line equate
                     connect-points location size (go-away t) (show t))
"Args: (data &key title variable-labels point-labels (jitter t)
             (y-axis-label \"Data\")
             (boxes t) diamonds median-line mean-line connect-points
             equate location size (go-away t) (show t))
DATA is a sequence, a list of sequences or a matrix. Plot is of the sequence or sequences in the list or the columns of the matrix. Makes one or many parallel dot plots, with optional boxplots and/or diamondplots superimposed.  Dots are jittered unless JITTER is nil. Points in parallel plots may be connected if each plot has the same number of observations. Parallel plots may also be connected with mean or median line.   Boxplots are based on the five number summary.  Diamond plots are based on the mean and standard deviation.  Widths of boxes and diamonds are proportional to number of observations in the sequence. The BOXES, DIAMONDS, MEAN-LINE and MEDIAN-LINE arguments determine which features are initially displayed.  Default is that only boxes are displayed. CONNECT-POINTS must be true to enable point connections (only appropriate for multivariate data). Points not jittered when connected. EQUATE displays equate box and normalizes all variables onto comparable scales."
  (send boxplot-proto :new data :title title :point-labels point-labels
        :variable-labels variable-labels :location location :boxes boxes
        :diamonds diamonds :median-line median-line :mean-line mean-line
        :enable-connect-points connect-points :enable-equate equate
        :jitter jitter :size size :go-away go-away :show show :content-only content-only
        :y-axis-label y-axis-label :legend1 legend1 :legend2 legend2)  )

(defun dotplot (data &key (title "Dot Plot") 
                     variable-labels point-labels (jitter t) 
                     (y-axis-label "Data") 
                     (legend1 (send current-object :name))  (legend2 " ")
                      location size (go-away t) (show t))
  (if (sequencep data)
      (send boxplot-proto :new data :title title :point-labels point-labels
            :variable-labels variable-labels :location location :boxes nil
            :diamonds nil :median-line nil :mean-line nil :dot-plot-only t
            :enable-connect-points nil :enable-equate nil
            :jitter jitter :size size :go-away go-away :show show
            :y-axis-label y-axis-label :legend1 legend1 :legend2 legend2)
      (error-message "Data must be a single sequence")))

(defproto boxplot-proto '(data normed-data x boxes diamonds y-axis-label
                               mean-line median-line line-state button-overlay
                               equate enable-equate jitter num-obs num-var
                               enable-connect-points connect-points
                               show-variable-labels grouped active-label
                               legend1 legend2 retain-point-states notched?) 
  () scatterplot-proto)

(defmeth boxplot-proto :data (&optional (sequence nil set))
"Args: (&optional sequence)
Sets or returns the plot data for the y-axis."
  (if set (setf (slot-value 'data) sequence))
  (slot-value 'data))

(defmeth boxplot-proto :normed-data (&optional (sequence nil set))
"Args: (&optional sequence)
Sets or returns the normed plot data for the y-axis."
  (if set (setf (slot-value 'normed-data) sequence))
  (slot-value 'normed-data))

(defmeth boxplot-proto :button-overlay (&optional (obj-id nil set))
"Args: (&optional obj-id)
Sets or returns the object id of the button overlay."
  (if set (setf (slot-value 'button-overlay) obj-id))
  (slot-value 'button-overlay))

(defmeth boxplot-proto :retain-point-states (&optional (logical nil set))
"Args: (&optional obj-id)
Sets or returns whether point states (colors, symbols, states) are retained for new plots."
  (if set (setf (slot-value 'retain-point-states) logical))
  (slot-value 'retain-point-states ))

(defmeth boxplot-proto :show-variable-labels (&optional (logical nil set))
"Args: (&optional obj-id)
Sets or returns whether variable labels are to be shown."
  (if set (setf (slot-value 'show-variable-labels) logical))
  (slot-value 'show-variable-labels))

(defmeth boxplot-proto :x (&optional (list nil set))
"Args: (&optional list)
Sets or returns the plot data for the x-axis."
  (if set (setf (slot-value 'x) list))
  (slot-value 'x))

(defmeth boxplot-proto :num-obs (&optional (value nil set))
"Args: (&optional sequence)
Sets or returns the number of observations."
  (if set (setf (slot-value 'num-obs) value))
  (slot-value 'num-obs))

(defmeth boxplot-proto :active-label (&optional (value nil set))
"Args: (&optional sequence)
Sets or returns the number of the active-label."
  (unless (send self :has-slot 'active-label)
          (send self :add-slot 'active-label))
  (if set (setf (slot-value 'active-label) value))
  (slot-value 'active-label))

(defmeth boxplot-proto :num-var (&optional (value nil set))
"Args: (&optional value)
Sets or returns the number of variables."
  (if set (setf (slot-value 'num-var) value))
  (slot-value 'num-var))

(defmeth boxplot-proto :jitter (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns t or nil for jittering."
  (if set (setf (slot-value 'jitter) logical))
  (slot-value 'jitter))

(defmeth boxplot-proto :grouped (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns t or nil inidicating if this is a grouped boxplot."
  (if set (setf (slot-value 'grouped) logical))
  (slot-value 'grouped))

(defmeth boxplot-proto :boxes (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns t or nil for boxes showing."
  (if set (setf (slot-value 'boxes) logical))
  (slot-value 'boxes))

(defmeth boxplot-proto :diamonds (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns t or nil for diamonds showing."
  (if set (setf (slot-value 'diamonds) logical))
  (slot-value 'diamonds))

(defmeth boxplot-proto :mean-line (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns t or nil for mean line showing."
  (if set (setf (slot-value 'mean-line) logical))
  (slot-value 'mean-line))

(defmeth boxplot-proto :median-line (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns t or nil for median line showing."
  (if set (setf (slot-value 'median-line) logical))
  (slot-value 'median-line))

(defmeth boxplot-proto :connect-points (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns t or nil for drawing lines connecting parallel points."
  (if set (setf (slot-value 'connect-points) logical))
  (slot-value 'connect-points))

(defmeth boxplot-proto :equate (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns t or nil for normalizing variables onto comparable scales."
  (if set (setf (slot-value 'equate) logical))
  (slot-value 'equate))

(defmeth boxplot-proto :enable-connect-points (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns t or nil for enabling point connecting feature."
  (if set (setf (slot-value 'enable-connect-points) logical))
  (slot-value 'enable-connect-points))

(defmeth boxplot-proto :enable-equate (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns t or nil for enabling equate feature."
  (if set (setf (slot-value 'enable-equate) logical))
  (slot-value 'enable-equate))

(defmeth boxplot-proto :line-state (&optional (logical nil set))
"Args: (&optional logical)
Sets or returns line state. States can be T (drawn) or NIL (none)."
  (if set (setf (slot-value 'line-state) logical))
  (slot-value 'line-state))

(defmeth boxplot-proto :y-axis-label (&optional (string nil set))
"Args: (&optional logical)
Sets or returns name of the y-axis."
  (if set (setf (slot-value 'y-axis-label) string))
  (slot-value 'y-axis-label))

(defmeth boxplot-proto :legend1 (&optional (string nil set))
  (if set (setf (slot-value 'legend1) string))
  (slot-value 'legend1))

(defmeth boxplot-proto :legend2 (&optional (string nil set))
  (if set (setf (slot-value 'legend2) string))
  (slot-value 'legend2))

(defmeth boxplot-proto :notched? (&optional (logical nil set))
  (if set (setf (slot-value 'notched?) logical))
  (slot-value 'notched?))


(defun position-categories (var)
    (mapcar #' (lambda (rd) (which (mapcar #'(lambda (ch) (equal rd ch)) var)))
          (remove-duplicates var  :test 'equal)))

(defmeth boxplot-proto :isnew 
  (data &key title variable-labels point-labels enable-equate jitter
        boxes diamonds mean-line median-line enable-connect-points
        y-axis-label location size go-away show legend1 legend2
        dot-plot-only (original-order nil) grouped content-only)
  (send self :content-only content-only)
  (send self :grouped grouped)
  (when original-order
        (send self :add-slot 'original-order);PV 
        (send self :slot-value 'original-order original-order));PV used for re-sorting the data
  (send self :data 
        (cond ((matrixp data) (column-list data))
          ((or (not (listp data)) (numberp (car data))) (list data))
          (t data)))
  (send self :num-obs (length (first (send self :data))))
  (send self :num-var (length (send self :data)))
  (send self :show-variable-labels nil)
  (let ((initial (send self :show-variable-labels)))
    (send self :show-variable-labels nil)
    (call-next-method 2 :title title :variable-labels variable-labels
                      :location location :size size :go-away go-away :show nil)
    (send self :show-variable-labels initial))
  (let* ((n nil)
         (x nil)
         (loc nil)
         (box-redraw 
          (send graph-item-proto :new "Redraw Plot" self :refresh-screen))
         )
    (send self :legend1 legend1)
    (send self :legend2 legend2)
    (send self :x-axis nil )
     
   (send self :make-two-plot-menus 
        "BoxPlot"
        :hotspot-items '(
                         help dash link dash
                              print save copy
                              )
        :popup-items '(showing-labels mouse resize-brush dash
                       erase-selection focus-on-selection view-selection dash 
                       select-all show-all dash
                       symbol color))


          
    (send self :button-overlay
          (send self :plot-buttons :margin (list
                                            0 (+ 17 (send self :text-descent)) 
                                            0 (+ 17 (send self :text-descent)))
                :new-x nil :new-y nil :mouse-mode t :equate enable-equate))
    (unless dot-plot-only 
            (send self :add-overlay (send boxplot-overlay-proto :new)))
    (send self :boxes boxes)
    (send self :diamonds diamonds)
    (send self :median-line median-line)
    (send self :mean-line mean-line)
    (send self :jitter jitter)
    (send self :connect-points nil)
    (send self :enable-equate enable-equate)
    (send self :equate enable-equate)
    (send self :enable-connect-points enable-connect-points)
    (send self :retain-point-states enable-connect-points)
    (when *color-mode* (send self :use-color t))
    (send self :brush 0 0 20 10)
    (send self :y-axis-label y-axis-label)
    (when (not point-labels) 
          (setf point-labels
                (mapcar #'(lambda (i) (format nil "~d" i))
                        (iseq (send self :num-obs)))))
    (when enable-equate (send self :normed-data (send self :normalize data)))
    (send self :new-plot (send self :data) 
          :title title
          :variable-labels variable-labels
          :point-labels point-labels)
    (send self :show-variable-labels t)
    (send self :showing-labels nil)
    (apply #'send self :margin (+ (send self :margin) (list 0 0 10 5)))
    (when show (send self :show-window))
    self))

;;MODIFIED STANDARD GRAPH METHODS

(defmeth boxplot-proto :equate-on (nilt)
  (send self :enable-equate nilt)
  (send self :equate nilt)
  (when nilt (send self :normed-data (send self :normalize data))))

(defmeth boxplot-proto :switch-use-color ()
  (send self :use-color (not (send self :use-color)))
  (send self :change-plot)
  (send self :use-color))

(defmeth boxplot-proto :redraw ()
  (send self :start-buffering)
  (call-next-method)
  (when (send self :show-variable-labels) (send self :add-labels ))
  (let* ((line1 (+ (second (send self :margin)) 
                   (send self :text-ascent) (send self :text-descent)))
         (line2 (+ line1 1
                   (send self :text-ascent) (send self :text-descent)))
         
         (plot-type ""))
    (cond 
      ((send self :boxes) 
         (setf plot-type "Box")
         (when (send self :diamonds) 
               (setf plot-type "Box and Diamond")))
      ((send self :diamonds) (setf plot-type "Diamond"))
      (t (setf plot-type "Dot")))
    (when (and (send self :enable-connect-points)
               (send self :connect-points ))
          (setf plot-type (strcat "Connected " plot-type)))
    (when (send self :grouped) (setf plot-type (strcat "Grouped " plot-type)))
    (when (equal plot-type "Connected Dot") 
          (setf plot-type "Parallel Coordinates"))
    (send self :legend2 " ")
    (send self :buffer-to-screen)))
  

(defmeth boxplot-proto :draw-legends ()
  (unless (send self :content-only)
  (let* ((line1 (+ (second (send self :margin)) 
                   (send self :text-ascent) (send self :text-descent)))
         (line2 (+ line1 1
                   (send self :text-ascent) (send self :text-descent)))
         (cr (send self :content-rect))
         (center (+ (first cr) (floor (/ (third cr) 2))))
         (legend1 (send self :legend1)))
    
    (when legend1 (send self :draw-text legend1 center line1 1 0))
                    ;    (floor (/ (first (send self :size)) 2))
    (send self :draw-text (send self :legend2) center line2 1 0)
          ;(floor (/ (first (send self :size)) 2)) line2 1 0
    )))

(defmeth boxplot-proto :add-grid ()
  (when (send self :real-to-canvas 0 0)
        (let* ((cv (send self :content-variables))
               (rangex (send self :range (first cv)))
               (rangey (send self :range (second cv)))
               (minx (first  rangex))
               (maxx (second rangex))
               (miny (first  rangey))
               (maxy (second rangey))
               (line1start (+ (send self :real-to-canvas minx maxy) (list -15 -5)))
               (line2start (+ (send self :real-to-canvas maxx maxy) (list 0 -5)))
               (line3start (+ (send self :real-to-canvas maxx miny) (list 0 5)))
               (line4start (+ (send self :real-to-canvas minx miny) (list -15 5))) )
          (when (and line1start)
                (apply #'send self :draw-line 
                       (combine line1start line2start))
                (apply #'send self :draw-line 
                       (combine line2start line3start))
                (apply #'send self :draw-line 
                       (combine line3start line4start))
                (apply #'send self :draw-line
                       (combine line4start line1start))
                ))))

(defmeth boxplot-proto :redraw-content ()
  (call-next-method)
  (when (send self :real-to-canvas 0 0)
  (let* ((dc (send self :draw-color))
         (bc (send self :back-color))
         (cv (send self :content-variables))
         (rangex (send self :range (first cv)))
         (rangey (send self :range (second cv)))
         (minx (first  rangex))
         (maxx (second rangex))
         (miny (first  rangey))
         (maxy (second rangey))
         (line1start (+ (send self :real-to-canvas minx maxy) (list -15 -5)))
         (line2start (+ (send self :real-to-canvas maxx maxy) (list 0 -5)))
         (line3start (+ (send self :real-to-canvas maxx miny) (list 0 5)))
         (line4start (+ (send self :real-to-canvas minx miny) (list -15 5)))
         (xyup (- line1start (list -10 -2)))
         (xydw (- line4start (list -10 +2)))
         (miny (second xydw))
         (maxy (second xyup))
         (width 15))
    (send self :draw-color bc)
    (apply #'send self :paint-rect (combine xyup (list 5 (- miny maxy))));(- miny maxy)
    (send self :draw-color dc)
    (when (and line1start)
          (apply #'send self :draw-line (combine line1start line2start))
          (apply #'send self :draw-line (combine line2start line3start))
          (apply #'send self :draw-line (combine line3start line4start))
          (apply #'send self :draw-line (combine line4start line1start)))
    (send self :draw-legends)
    )))

(defmeth boxplot-proto :refresh-screen ()
  (send self :start-buffering)
  (send self :change-plot)
  (send self :adjust-screen)
  (send self :buffer-to-screen)
  )

(defmeth boxplot-proto :unselect-all-points ()
  (when (send self :any-points-selected-p)
        (let* ((num-obs (send self :num-obs))
               (num-var (send self :num-var))
               (selected-pts (send self :selection)))
          (send self :propagate-selection selected-pts 'normal 
                num-obs num-var)))
  (call-next-method))

(defmeth boxplot-proto :adjust-screen ()
  (let ((num-obs (send self :num-obs))
        (num-var (send self :num-var))
        )
    (when (> num-var 1)
          (let* ((point-states (send self :point-state (iseq num-obs)))
                 (selected-pts  
                  (which (map-elements #'eq 'selected point-states)))
                 (hilited-pts
                  (which (map-elements #'eq 'hilited point-states)))
                 (invisible-pts
                  (which (map-elements #'eq 'invisible point-states)))
                 (both-pts (append selected-pts hilited-pts))
                 (higher-point-states nil)
                 (higher-both-pts nil)
                 (lower-both-pts nil)
                 )
            (send self :start-buffering)
          ;  (format t "BP: Adjust Screen ~d~%" (list point-states))
            (when (and invisible-pts (send self :button-overlay))
                  (send self :parallel invisible-pts 'normal
                        num-obs num-var)
                  (send self :change-plot))
            (when selected-pts
                  (send self :propagate-selection selected-pts 'selected
                         num-obs num-var))
            (when hilited-pts
                  (send self :propagate-selection hilited-pts 'hilited
                         num-obs num-var))
            (setf higher-point-states 
                  (send self :point-state (iseq num-obs (- (* num-obs num-var) 1))))
            ;(break)
            (setf higher-both-pts (append
                  (which (map-elements #'eq 'selected higher-point-states))
                  (which (map-elements #'eq 'hilited higher-point-states))))
            ;(format t "BP: Adjust ScreenB ~d ~d~%"higher-both-pts both-pts)
            (when (and higher-both-pts (not both-pts))
                  (setf lower-both-pts 
                        (select higher-both-pts 
                                (which (< higher-both-pts num-obs))))
                  (when lower-both-pts
                        (send self :propagate-selection 
                              lower-both-pts 'normal num-obs num-var)
                        (send self :change-plot)))
            (send self :x-axis nil nil 0)
            (send self :buffer-to-screen)
            ))))

(defmeth boxplot-proto :adjust-points-in-rect (x y w h s)
  (let* ((pts (send self :points-in-rect x y w h)))
    (cond 
      ((eq s 'selected) 
       (when (and (= w 0) (= h 0))
             (setf x (- x 2)) (setf y (- y 2))
             (setf w 4) (setf h 4)
             (setf pts (send self :points-in-rect x y w h))))
      ((eq s 'hilited)
       (when pts
             (when (and (= w 0) (= h 0))
                   (setf x (- x 2)) (setf y (- y 2))
                   (setf w 4) (setf h 4)
                   (setf pts (send self :points-in-rect x y w h))))))
    (send self :adjust-points pts s)))



(defmeth boxplot-proto :adjust-points (pts s &optional mouse-mode)
  (let* ((enabled (send self :enable-connect-points))
         (num-obs (if enabled
                      (send self :num-obs)
                      (length (combine (send self :data)))))
         (num-var (send self :num-var))
         )
;(format t "BP: Adjust Points: ~d~%" (list pts s))
    (when (not mouse-mode) (setf mouse-mode (send self :mouse-mode)))
    (cond 
      ((eq s 'selected) 
       (send self :propagate-selection 
             pts 'selected num-obs num-var mouse-mode)
       )
    ((eq s 'hilited)
     (let* ((point-states (send self :point-state (iseq num-obs)))
            (hilited-pts (which (map-elements #'eq 'hilited point-states)))
            (low-pts (if enabled (when pts (mod pts num-obs)) pts)))
       (when pts
             (send self :propagate-selection 
                   (set-difference hilited-pts low-pts) 'normal 
                   num-obs num-var mouse-mode)
             (send self :propagate-selection 
                   (set-difference low-pts hilited-pts) 'hilited
                    num-obs num-var mouse-mode)
             )
       (when (and hilited-pts (not pts))
             (send self :propagate-selection hilited-pts 'normal
                    num-obs num-var mouse-mode)
             (send self :change-plot)))))))
    

(defmeth boxplot-proto :adjust-to-data ()
;disabled to prevent show all from messing up
  )

;;PARALLEL BOXES METHODS

(defmeth boxplot-proto :propagate-selection 
             (pt s num-obs num-var &optional mouse-mode &key color symbol)
"Args: PT S NUM-OBS NUM-VAR &OPTIONAL MOUSE-MODE
For parallel boxplots, propagates point state S (NORMAL, SELECTED OR HILITED) of points PT when NUM-OBS points are connected on NUM-VAR parallel variables. Uses self mouse-mode when MOUSE-MODE is nil, another windows MOUSE-MODE when not nil. Propages COLOR and SYMBOL when specified."
 ; (format t "BP: Propagate Selection ~d~%" (list pt s))
  (let ((num-obs (send self :num-obs))
        (enabled (send self :enable-connect-points))
        (connect (send self :connect-points))
        (num-var (send self :num-var))
        (color?  (and (send (send self :button-overlay) :color-mode) 
                      (> *color-mode* 0)))
        )
    (when (not mouse-mode) (setf mouse-mode (send self :mouse-mode)))
    (cond
      ((and enabled (> num-var 1))
       (when pt
             (when (eq mouse-mode 'selecting)
                   (send self :change-plot))
             (dotimes (i num-var)
                      (send self :point-state
                            (+ (mod pt num-obs) (* i num-obs)) s)
                      (when color 
                            (send self :point-color
                                  (+ (mod pt num-obs) (* i num-obs)) 
                                  (if color? color)))
                      (when symbol
                            (send self :point-symbol
                                  (+ (mod pt num-obs) (* i num-obs)) symbol))
                      )
             (when (and enabled connect) 
                   (send self :parallel pt s num-obs num-var mouse-mode)))
       (when (and (not pt) enabled connect) 
             (send self :parallel pt s num-obs num-var mouse-mode)))
      (t
       (when pt (send self :point-state pt s))))))


(defmeth boxplot-proto :parallel (pti s num-obs num-var &optional mouse-mode)
"Args: PTI S
Draws parallel boxplot connecting lines for points PTI. If S is 'NORMAL, erases lines by drawing in background color. Uses self mouse-mode when MOUSE-MODE is nil, another windows MOUSE-MODE when not nil."
 ; (format t "BP: Parallel~d~%"(list pti s))
  (when (not mouse-mode) (setf mouse-mode (send self :mouse-mode)))
  (cond 
    (pti
     (let* (

;(junk (break))
            (data (if (send self :equate)
                      (send self :normed-data)
                      (send self :data)))
            (pt (mod pti num-obs))
            (draw-color (send self :draw-color))
            (back-color (send self :back-color))
            (line-color nil)
            (color-on? (and (send (send self :button-overlay) :color-mode) 
                            (> *color-mode* 0)))
            (ptnow nil))
;(break)
       (dotimes (i (length pt))
                (setf ptnow (select pt i))
                (when color-on?
                      (setf line-color (send self :point-color ptnow))
                      (if (not line-color) (setf line-color 'black))
                      (if (eq s 'normal) (setf line-color back-color)))
                (send self :add-lines 
                  (send self :point-coordinate 0 
                        (rseq ptnow 
                              (+ ptnow (* (- num-var 1) num-obs)) num-var))
                  (send self :point-coordinate 1 
                        (rseq ptnow 
                              (+ ptnow (* (- num-var 1) num-obs)) num-var))
                      :color line-color
                      ))
       (when (not (or (send self :diamonds) (send self :boxes)))
             (when (send self :showing-labels) (send self :add-labels)))
       ))
    (t 
     (when (eq mouse-mode 'selecting) (send self :change-plot))
     )))

;(load (strcat *code-dir-name* "boxplot2"))
